A base de dados escolhida se encontra no endereço Pumpkin Seeds Dataset. Ela foi criada para classificação de sementes com base em características morfológicas extraídas de imagens. Isso tem aplicações diretas em: Agricultura de precisão, estudos botânicos e em processos industriais de seleção de sementes.
dados_originais <- read_excel("Pumpkin_Seeds_Dataset.xlsx")
set.seed(223)
dados_reduzidos <- dados_originais %>% slice_sample(n = 500)
dados_reduzidos <- as.data.frame(dados_reduzidos)
dados_long <- melt(dados_reduzidos, id.vars = "Class")
ggplot(dados_long, aes(x=Class, y=value, fill=Class)) +
geom_boxplot(alpha=0.7) +
facet_wrap(~ variable, scales='free_y') +
labs(title = "Boxplots dos atributos por classe")
ggpairs(dados_reduzidos,
columns = 1:12, # Apenas variáveis numéricas
aes(color = Class), # Cor por classe
upper = list(continuous = "points"),
lower = list(continuous = "smooth"),
diag = list(continuous = "densityDiag")) +
theme_linedraw()
dados <- dados_reduzidos %>% dplyr::select(-Class)
knitr::kable(head(dados), caption = "Primeiras linhas do conjunto de dados de sementes de abóbora")
| Area | Perimeter | Major_Axis_Length | Minor_Axis_Length | Convex_Area | Equiv_Diameter | Eccentricity | Solidity | Extent | Roundness | Aspect_Ration | Compactness |
|---|---|---|---|---|---|---|---|---|---|---|---|
| 60925 | 957.318 | 375.9761 | 207.4241 | 61599 | 278.5177 | 0.8340 | 0.9891 | 0.7122 | 0.8354 | 1.8126 | 0.7408 |
| 83832 | 1135.230 | 448.0772 | 239.1491 | 84719 | 326.7082 | 0.8457 | 0.9895 | 0.7613 | 0.8174 | 1.8736 | 0.7291 |
| 77070 | 1152.830 | 486.4784 | 202.5228 | 77800 | 313.2548 | 0.9092 | 0.9906 | 0.5715 | 0.7287 | 2.4021 | 0.6439 |
| 71614 | 1036.482 | 405.5690 | 226.0209 | 72260 | 301.9632 | 0.8303 | 0.9911 | 0.6897 | 0.8377 | 1.7944 | 0.7445 |
| 66259 | 1013.800 | 410.5810 | 206.1564 | 66874 | 290.4541 | 0.8648 | 0.9908 | 0.7326 | 0.8101 | 1.9916 | 0.7074 |
| 65787 | 1021.125 | 409.1759 | 205.6027 | 66648 | 289.4177 | 0.8646 | 0.9871 | 0.6096 | 0.7929 | 1.9901 | 0.7073 |
str(dados) # Estrutura das variáveis
## 'data.frame': 500 obs. of 12 variables:
## $ Area : num 60925 83832 77070 71614 66259 ...
## $ Perimeter : num 957 1135 1153 1036 1014 ...
## $ Major_Axis_Length: num 376 448 486 406 411 ...
## $ Minor_Axis_Length: num 207 239 203 226 206 ...
## $ Convex_Area : num 61599 84719 77800 72260 66874 ...
## $ Equiv_Diameter : num 279 327 313 302 290 ...
## $ Eccentricity : num 0.834 0.846 0.909 0.83 0.865 ...
## $ Solidity : num 0.989 0.99 0.991 0.991 0.991 ...
## $ Extent : num 0.712 0.761 0.572 0.69 0.733 ...
## $ Roundness : num 0.835 0.817 0.729 0.838 0.81 ...
## $ Aspect_Ration : num 1.81 1.87 2.4 1.79 1.99 ...
## $ Compactness : num 0.741 0.729 0.644 0.745 0.707 ...
summary(dados) # Estatísticas básicas
## Area Perimeter Major_Axis_Length Minor_Axis_Length
## Min. : 51555 Min. : 899.5 Min. :320.8 Min. :164.7
## 1st Qu.: 71621 1st Qu.:1058.3 1st Qu.:419.3 1st Qu.:210.8
## Median : 79195 Median :1126.2 Median :449.3 Median :224.4
## Mean : 81013 Mean :1134.0 Mean :458.3 Mean :226.0
## 3rd Qu.: 89286 3rd Qu.:1202.9 3rd Qu.:492.6 3rd Qu.:241.2
## Max. :135455 Max. :1491.9 Max. :623.0 Max. :297.8
## Convex_Area Equiv_Diameter Eccentricity Solidity
## Min. : 52013 Min. :256.2 Min. :0.4921 Min. :0.9186
## 1st Qu.: 72482 1st Qu.:302.0 1st Qu.:0.8338 1st Qu.:0.9880
## Median : 79997 Median :317.5 Median :0.8649 Median :0.9901
## Mean : 81892 Mean :320.1 Mean :0.8617 Mean :0.9891
## 3rd Qu.: 90187 3rd Qu.:337.2 3rd Qu.:0.8959 3rd Qu.:0.9914
## Max. :136373 Max. :415.3 Max. :0.9464 Max. :0.9944
## Extent Roundness Aspect_Ration Compactness
## Min. :0.5119 Min. :0.5825 Min. :1.149 Min. :0.5670
## 1st Qu.:0.6526 1st Qu.:0.7528 1st Qu.:1.812 1st Qu.:0.6651
## Median :0.7119 Median :0.7931 Median :1.992 Median :0.7056
## Mean :0.6920 Mean :0.7899 Mean :2.048 Mean :0.7030
## 3rd Qu.:0.7403 3rd Qu.:0.8312 3rd Qu.:2.251 3rd Qu.:0.7414
## Max. :0.7810 Max. :0.9396 Max. :3.097 Max. :0.9049
O data frame dados possui 16 variáveis numéricas que descrevem características morfológicas das sementes de abóbora, como área, perímetro, redondeza e razão de aspecto. Essas variáveis serão utilizadas para classificar os tipos de sementes presentes no conjunto.
dados_padronizados <- scale(dados)
ground_truth <- dados_reduzidos$Class
n_rows <- nrow(dados_padronizados)
k_clusters <- 2 # numero de clusters
set.seed(223)
kmeans_res <- kmeans(dados_padronizados, centers = k_clusters, nstart = 25)
pam_res <- pam(dados_padronizados, k = k_clusters)
dist_matrix <- dist(dados_padronizados, method = "euclidean")
hc_res <- hclust(dist_matrix, method = "ward.D2") # linkage Ward
hc_clusters <- cutree(hc_res, k = k_clusters)
sil_kmeans <- silhouette(kmeans_res$cluster, dist(dados_padronizados))
sil_pam <- silhouette(pam_res$clustering, dist(dados_padronizados))
sil_hc <- silhouette(hc_clusters, dist(dados_padronizados))
wss_kmeans <- kmeans_res$tot.withinss
wss_pam <- sum(sapply(1:k_clusters, function(k) sum((dados_padronizados[pam_res$clustering == k, ] - pam_res$medoids[k, ])^2)))
wss_hc <- sum(sapply(1:k_clusters, function(k) {
cluster_points <- dados_padronizados[hc_clusters == k, , drop = FALSE]
center <- colMeans(cluster_points)
sum(rowSums((cluster_points - center)^2))
}))
db_kmeans <- index.DB(dados_padronizados, kmeans_res$cluster)$DB
db_pam <- index.DB(dados_padronizados, pam_res$clustering)$DB
db_hc <- index.DB(dados_padronizados, hc_clusters)$DB
cat("Resultados (Métricas Internas):\n")
## Resultados (Métricas Internas):
cat("K-Means - Silhueta:", mean(sil_kmeans[, 3]),
" WSS:", wss_kmeans,
" DBI:", db_kmeans, "\n")
## K-Means - Silhueta: 0.305765 WSS: 4119.997 DBI: 1.474202
cat("PAM - Silhueta:", mean(sil_pam[, 3]),
" WSS:", wss_pam,
" DBI:", db_pam, "\n")
## PAM - Silhueta: 0.3124865 WSS: 7407.68 DBI: 1.456355
cat("Hierárq - Silhueta:", mean(sil_hc[, 3]),
" WSS:", wss_hc,
" DBI:", db_hc, "\n")
## Hierárq - Silhueta: 0.2857827 WSS: 7343.582 DBI: 1.557811
resultados <- data.frame(
Algoritmo = c("K-Means", "PAM", "Hierárquico"),
Silhueta = c(mean(sil_kmeans[, 3]), mean(sil_pam[, 3]), mean(sil_hc[, 3])),
WSS = c(wss_kmeans, wss_pam, wss_hc),
DBI = c(db_kmeans, db_pam, db_hc)
)
print(resultados)
## Algoritmo Silhueta WSS DBI
## 1 K-Means 0.3057650 4119.997 1.474202
## 2 PAM 0.3124865 7407.680 1.456355
## 3 Hierárquico 0.2857827 7343.582 1.557811
p1 <- ggplot(resultados, aes(x = Algoritmo, y = Silhueta, fill = Algoritmo)) +
geom_bar(stat = "identity") +
ggtitle("Comparação - Coeficiente de Silhueta") +
theme_minimal()
p2 <- ggplot(resultados, aes(x = Algoritmo, y = WSS, fill = Algoritmo)) +
geom_bar(stat = "identity") +
ggtitle("Comparação - WSS (Within-cluster Sum of Squares)") +
theme_minimal()
p3 <- ggplot(resultados, aes(x = Algoritmo, y = DBI, fill = Algoritmo)) +
geom_bar(stat = "identity") +
ggtitle("Comparação - Davies-Bouldin Index") +
theme_minimal()
grid.arrange(p1, p2, p3, nrow = 3)
Nesse cenário, o algoritmo PAM apresentou o melhor desempenho geral, com o maior índice de silhueta e o menor DBI, indicando boa separação entre os grupos e baixa sobreposição. Apesar do WSS elevado, o modelo mostrou-se mais coeso e interpretável.
rho <- rcorr(as.matrix(dados_padronizados), type="pearson")
corr_coef <- rho$r # Matriz de correlações
corr_sig <- round(rho$P, 5) # Matriz com p-valor dos coeficientes
ggplotly(
dados_padronizados %>%
cor() %>%
melt() %>%
rename(Correlação = value) %>%
ggplot() +
geom_tile(aes(x = Var1, y = Var2, fill = Correlação)) +
scale_fill_viridis_b() +
labs(x = NULL, y = NULL) +
theme_bw(base_size = 6))
cortest.bartlett(dados_padronizados)
## R was not square, finding R from data
## $chisq
## [1] 24698.48
##
## $p.value
## [1] 0
##
## $df
## [1] 66
Encontramos p.value é igual a zero
fatorial <- principal(dados_padronizados,
nfactors = ncol(dados_padronizados),
rotate = "none",
scores = TRUE)
cum_var <- fatorial$Vaccounted["Cumulative Var", ]
cum_var
## PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8
## 0.4782643 0.8291104 0.9158666 0.9856008 0.9955125 0.9991007 0.9995176 0.9998248
## PC9 PC10 PC11 PC12
## 0.9999793 0.9999943 0.9999996 1.0000000
num_comp <- which(cum_var >= 0.7)[1]
num_comp
## PC2
## 2
variancia_compartilhada <- as.data.frame(fatorial$Vaccounted) %>%
slice(1:3)
rownames(variancia_compartilhada) <- c("Autovalores",
"Prop. da Variância",
"Prop. da Variância Acumulada")
round(variancia_compartilhada, 3) %>%
kable() %>%
kable_styling(bootstrap_options = "striped",
full_width = FALSE,
font_size = 20)
| PC1 | PC2 | PC3 | PC4 | PC5 | PC6 | PC7 | PC8 | PC9 | PC10 | PC11 | PC12 | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Autovalores | 5.739 | 4.210 | 1.041 | 0.837 | 0.119 | 0.043 | 0.005 | 0.004 | 0.002 | 0 | 0 | 0 |
| Prop. da Variância | 0.478 | 0.351 | 0.087 | 0.070 | 0.010 | 0.004 | 0.000 | 0.000 | 0.000 | 0 | 0 | 0 |
| Prop. da Variância Acumulada | 0.478 | 0.829 | 0.916 | 0.986 | 0.996 | 0.999 | 1.000 | 1.000 | 1.000 | 1 | 1 | 1 |
pca_df <- data.frame(
fatorial$scores[, 1:2],
classe_da_semente = dados_reduzidos$Class
)
ggplot(pca_df, aes(x = PC1, y = PC2, color = classe_da_semente)) +
geom_point(size = 3, alpha = 0.8) +
labs(title = "PCA - Classe da Semente",
x = "Componente Principal 1",
y = "Componente Principal 2") +
theme_minimal()
pca_df_long <- melt(pca_df, id.vars = "classe_da_semente")
ggplot(pca_df_long, aes(x=classe_da_semente, y=value, fill=classe_da_semente)) +
geom_boxplot(alpha=0.7) +
facet_wrap(~ variable, scales='free_y') +
labs(title = "Boxplots dos componentes gerados no PCA")
dados_pca_df <- pca_df %>% dplyr::select(-classe_da_semente)
knitr::kable(head(pca_df), caption = "Primeiras linhas do conjunto de dados de sementes de abóbora após o PCA")
| PC1 | PC2 | classe_da_semente |
|---|---|---|
| -1.4913049 | -0.6421392 | Çerçevelik |
| -0.2311063 | 0.6059733 | Çerçevelik |
| 0.6469567 | -1.1201075 | Ürgüp Sivrisi |
| -0.9808628 | 0.0466117 | Çerçevelik |
| -0.8507799 | -0.6896804 | Ürgüp Sivrisi |
| -0.7463888 | -0.9529656 | Çerçevelik |
str(dados_pca_df) # Estrutura das variáveis
## 'data.frame': 500 obs. of 2 variables:
## $ PC1: num -1.491 -0.231 0.647 -0.981 -0.851 ...
## $ PC2: num -0.6421 0.606 -1.1201 0.0466 -0.6897 ...
summary(dados_pca_df) # Estatísticas básicas
## PC1 PC2
## Min. :-2.9583 Min. :-3.56295
## 1st Qu.:-0.6791 1st Qu.:-0.60628
## Median :-0.1248 Median :-0.01365
## Mean : 0.0000 Mean : 0.00000
## 3rd Qu.: 0.6484 3rd Qu.: 0.62758
## Max. : 2.9372 Max. : 3.07587
ground_truth_pca_df <- pca_df$classe_da_semente
n_rows_pca_df <- nrow(dados_pca_df)
k_clusters_pca_df <- 2 # numero de clusters
set.seed(223)
kmeans_res_pca_df <- kmeans(dados_pca_df, centers = k_clusters, nstart = 25)
pam_res_pca_df <- pam(dados_pca_df, k = k_clusters)
dist_matrix_pca_df <- dist(dados_pca_df, method = "euclidean")
hc_res_pca_df <- hclust(dist_matrix_pca_df, method = "ward.D2") # linkage Ward
hc_clusters_pca_df <- cutree(hc_res_pca_df, k = k_clusters)
sil_kmeans_pca_df <- silhouette(kmeans_res_pca_df$cluster, dist(dados_pca_df))
sil_pam_pca_df <- silhouette(pam_res_pca_df$clustering, dist(dados_pca_df))
sil_hc_pca_df <- silhouette(hc_clusters_pca_df, dist(dados_pca_df))
wss_kmeans_pca_df <- kmeans_res_pca_df$tot.withinss
wss_pam_pca_df <- sum(sapply(1:k_clusters_pca_df, function(k) sum((dados_pca_df[pam_res_pca_df$clustering == k, ] - pam_res_pca_df$medoids[k, ])^2)))
wss_hc_pca_df <- sum(sapply(1:k_clusters_pca_df, function(k) {
cluster_points <- dados_pca_df[hc_clusters == k, , drop = FALSE]
center <- colMeans(cluster_points)
sum(rowSums((cluster_points - center)^2))
}))
db_kmeans_pca_df <- index.DB(dados_pca_df, kmeans_res_pca_df$cluster)$DB
db_pam_pca_df <- index.DB(dados_pca_df, pam_res_pca_df$clustering)$DB
db_hc_pca_df <- index.DB(dados_pca_df, hc_clusters_pca_df)$DB
cat("Resultados (Métricas Internas):\n")
## Resultados (Métricas Internas):
cat("K-Means - Silhueta:", mean(sil_kmeans_pca_df[, 3]),
" WSS:", wss_kmeans_pca_df,
" DBI:", db_kmeans_pca_df, "\n")
## K-Means - Silhueta: 0.3289184 WSS: 662.7697 DBI: 1.405934
cat("PAM - Silhueta:", mean(sil_pam_pca_df[, 3]),
" WSS:", wss_pam_pca_df,
" DBI:", db_pam_pca_df, "\n")
## PAM - Silhueta: 0.320953 WSS: 801.265 DBI: 1.429305
cat("Hierárq - Silhueta:", mean(sil_hc_pca_df[, 3]),
" WSS:", wss_hc_pca_df,
" DBI:", db_hc_pca_df, "\n")
## Hierárq - Silhueta: 0.3116495 WSS: 1212.051 DBI: 1.420029
resultados_pca_df <- data.frame(
Algoritmo = c("K-Means", "PAM", "Hierárquico"),
Silhueta = c(mean(sil_kmeans_pca_df[, 3]), mean(sil_pam_pca_df[, 3]), mean(sil_hc_pca_df[, 3])),
WSS = c(wss_kmeans_pca_df, wss_pam_pca_df, wss_hc_pca_df),
DBI = c(db_kmeans_pca_df, db_pam, db_hc_pca_df)
)
print(resultados_pca_df)
## Algoritmo Silhueta WSS DBI
## 1 K-Means 0.3289184 662.7697 1.405934
## 2 PAM 0.3209530 801.2650 1.456355
## 3 Hierárquico 0.3116495 1212.0511 1.420029
p4 <- ggplot(resultados_pca_df, aes(x = Algoritmo, y = Silhueta, fill = Algoritmo)) +
geom_bar(stat = "identity") +
ggtitle("Comparação - Coeficiente de Silhueta") +
theme_minimal()
p5 <- ggplot(resultados, aes(x = Algoritmo, y = WSS, fill = Algoritmo)) +
geom_bar(stat = "identity") +
ggtitle("Comparação - WSS (Within-cluster Sum of Squares)") +
theme_minimal()
p6 <- ggplot(resultados, aes(x = Algoritmo, y = DBI, fill = Algoritmo)) +
geom_bar(stat = "identity") +
ggtitle("Comparação - Davies-Bouldin Index") +
theme_minimal()
grid.arrange(p4, p5, p6, nrow = 3)
Após a aplicação do PCA, que reduziu a dimensionalidade dos dados mantendo a maior parte da variância explicada, observou-se uma melhora significativa nos resultados dos modelos. Com a nova representação dos dados, o algoritmo K-Means passou a liderar em todas as métricas, apresentando maior coesão interna (menor WSS), melhor separação entre os clusters (maior silhueta) e menor sobreposição (menor DBI). Isso evidencia o impacto positivo da redução de dimensionalidade na performance dos modelos de agrupamento.